home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-stab.9 / f2c-stab / f2c-stabs / formout.scm < prev    next >
Encoding:
Text File  |  1996-03-31  |  3.1 KB  |  94 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; formout - Library for formatted output.
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;;
  5. ;;; Copyright (c) 1996 Harvey J. Stein <abel@netvision.net.il>, and
  6. ;;; eventually <hjstein@netvision.net.il>
  7. ;;; All Rights Reserved.
  8. ;;; 
  9. ;;; This package is covered by the GNU GPL.  You can freely use and
  10. ;;; distribute it as long as it stays under the GNU GPL, and as long as
  11. ;;; you distribute all the corresponding source code, and as long as this
  12. ;;; message and the above copyright notice remains.
  13. ;;;
  14. ;;; Usage:
  15. ;;; The point of this library is to pre-compile format statements so
  16. ;;; that output can be done quickly.  The idea is similar to that of
  17. ;;; string->regexp.  I had tried to use format from slib, but had
  18. ;;; found it too slow - presumably be cause each call to format has to
  19. ;;; parse things like "foo ~3,9s ~~...".  This library is used by
  20. ;;; calling make-fmt-fcn with a format string.  It returns a function
  21. ;;; of 2 arguments, a port and an object to output.
  22. ;;;
  23. ;;; A major drawback of this package is that it relies on a format
  24. ;;; implementation that understands ~s and ~a.  I should have used
  25. ;;; display and write, but then it'd be more difficult to support a
  26. ;;; port of #f meaning to return a string.
  27.  
  28. (define (realformout port data wid prec)
  29.   (let* ((s (number->string data))
  30.      (pnt (string-index "." s))
  31.      (exp (string-index "e" s))
  32.      (sl (string-length s)))
  33.     (cond (exp
  34.        (realformout port
  35.             (string->number (substring s 0 exp))
  36.             (- wid (- sl exp))
  37.             (max 0(- prec (- sl exp))))
  38.        (stringformoutnonquoted port
  39.               (substring s exp sl)
  40.               (- sl exp)))
  41.       (pnt
  42.        (stringformoutnonquoted port
  43.               (string-append
  44.                (substring s 0 (min sl (+ pnt prec 1)))
  45.                (make-string (max 0 (- prec (- sl pnt 1))) #\0))
  46.               (- wid))))))
  47.  
  48. (define (stringformoutquoted port data wid)
  49.   (let* ((l (string-length data))
  50.      (p (make-string (max 0 (- (abs wid) l 2)) #\space)))
  51.     (cond ((< wid 0)
  52.        (format port "~a" p)
  53.        (format port "~s" data))
  54.       (else
  55.        (format port "~s" data)
  56.        (format port "~a" p)))))
  57.  
  58.  
  59. (define (stringformoutnonquoted port data wid)
  60.   (let* ((l (string-length data))
  61.      (p (make-string (max 0 (- (abs wid) l)) #\space)))
  62.     (cond ((< wid 0)
  63.        (format port "~a" (string-append p data)))
  64.       (else
  65.        (format port "~a" (string-append data p))))))
  66.  
  67. (define (make-fmt-fcn s)
  68.   (let* ((sl        (string-length s))
  69.      (at-pos    (string-index "@" s))
  70.      (comma-pos (string-index "," s))
  71.      (typ       (car (string->list (substring s (- sl 1) sl))))
  72.      (wid-mult (if at-pos -1 1))
  73.      (spec (if at-pos (substring s 1 at-pos)
  74.            (substring s 1 (- sl 1))))
  75.      (wid (* wid-mult (string->number
  76.                (if comma-pos (substring spec 0 (- comma-pos 1))
  77.                    spec))))
  78.      (prec (if comma-pos (string->number (substring spec
  79.                             comma-pos
  80.                             (string-length spec)))
  81.            0)))
  82.     (case typ
  83.       ((#\s #\S)
  84.        (lambda (p d) (stringformoutquoted p d wid)))
  85.       ((#\a #\A)
  86.        (lambda (p d) (stringformoutnonquoted p d wid)))
  87.       ((#\f #\F)
  88.        (lambda (p d) (realformout p d wid prec))))))
  89.        
  90.  
  91.  
  92.  
  93. (provide "formout")
  94.